home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / epb233.zip / EPB233.PAS < prev   
Pascal/Delphi Source File  |  1993-04-09  |  49KB  |  1,671 lines
  1. {ED'S PASCAL BEAUTIFIER v2.33}
  2. {Copyright 1992 by Edward Lee}
  3. {edlee@chinet.chi.il.us}
  4. {Turbo Pascal v4.0}
  5.  
  6. {31Jan1990 20:00  Program begun}
  7. {1 Feb1990 16:41}
  8. {2 Feb1990 16:47  v1.0 complete  Capitalizes keywords}
  9. {4 Feb1990 22:34  v1.1 complete  -Lower case option added}
  10. {7 Feb1990 00:29  v1.2 complete  Non-alphabetic token padding added}
  11. {  Identifier parsing debugged}
  12. {25Mar1990 21:15  v1.3 maintenance   ) append rule modified;}
  13. { (***) parsing debugged; REGISTERS and TEXT keywords added}
  14. {26May1990 16:56  v1.4 complete  optimized loop in identifier parsing}
  15. {  Added identifier substitution option}
  16. {7 Sep1991 13:03  v1.5 maintenance}
  17. {  The inputfile and outputfile may have the same name.}
  18. {  If only the inputfile is specified, the outputfile is assumed to have}
  19. {  the same name unless -o to STDOUT is specified.}
  20. {  An extension of .PAS is assumed for filenames if the extension is not}
  21. {  specified.}
  22. {24Nov1991 21:30  v1.51 maintenance  corrected minor typos}
  23. {25Nov1991 06:45  v1.52 maintenance  corrected -i and -o options}
  24. {v1.6x were experimental hashing versions}
  25. {26Jan1992 23:15  v1.7}
  26. {  Added -m option for Mixed-case keywords.}
  27. {  The first instance of a user-defined identifier sets the precedent in}
  28. {  capitalization for all further instances of that identifier.}
  29. {24Feb1992 4:46  v1.71  Removed -Lowercase normalization for user identifiers}
  30. {19Mar1992  v2.0  Many rules have been added or modified.  This version}
  31. {  variably nests compound IF THEN ELSE, WHILE, FOR, REPEAT operations + more}
  32. {02May1992  v2.1  Bugfix.  Added pops for nested, non-compound FOR DOs}
  33. {                 and WHILE DOs.  Restored '(' padding.}
  34. {14Jun1992  v2.2  Bugfix.  Corrected indentation of nested IF THEN ELSE}
  35. {                 constructs, indentation of nested WHILE DO constructs}
  36. {16Jun1992        Added an ElseIndent that is independent from IfIndent
  37. {                 to allow:  ElseIndent=0 }
  38. {03Jul1992  v2.3  Replaced binary searches and insertion sorting with hybrid}
  39. {                 radix/child-sibling trees for faster average performance.}
  40. {04Jul1992  v2.31 Bugfix.  Corrected an underflow associated with the}
  41. {                 conditional line break after a RECORD identifier}
  42. {           v2.32 Modified indentation behavior after line breaks, Added}
  43. {                 a conditional line break after the OF keyword}
  44. {23July1992 v2.33 Bugfix.  Exponential real and hexadecimal constants}
  45. {                 are now mostly invisible to the indentation and identifier}
  46. {                 replacement routines.  I extend my apologies to anyone}
  47. {                 who was inconvenienced by the previous lack of this context}
  48. {                 sensitivity.}
  49. {24July1992       Added another error message for a full directory}
  50.  
  51. CONST
  52.   (* Hanging indents after various keywords, in spaces *)
  53.   BeginIndent = 0;   (* See LeftmostBeginIndent, below *)
  54.   CaseIndent = 5;
  55.   ConstIndent = 2;
  56.   ElseIndent = 3;
  57.   ForIndent = 4;
  58.   IfIndent = 3;
  59.   LabelIndent = 2;
  60.   LeftmostBeginIndent = 2;
  61.   ProcedureIndent = 2;
  62.   RecordIndent = 2;
  63.   RepeatIndent = 2;
  64.   TypeIndent = 2;
  65.   UntilIndent = 6;
  66.   VarIndent = 2;
  67.   WhileIndent = 6;
  68.   WithIndent = 5;
  69.   
  70.   
  71.   nkeys = 258;     (* The number of keywords in keylist[] *)
  72.   maxkeylen = 17;  (* The maximum length of any keyword in keylist[] *)
  73.   
  74.   (* If you want to insert or delete keywords  in the  following list,  you 
  75.  * must make sure that the constant NKEYS is updated so that it indicates 
  76.  * the number of keywords in the list and maintain the value of MAXKEYLEN 
  77.  * to be always 1 greater than the maximum length of  any keyword  in the 
  78.  * list.   The  order no  longer matters,  except that  placing the  most 
  79.  * frequent keys at the start of the list will speed up the processing of 
  80.  * your source programs.
  81.  *)
  82.   
  83.   keylist : ARRAY [1..nkeys] OF
  84.   STRING [maxkeylen] =
  85.   (
  86.   'Abs', 'Absolute', 'Addr', 'And', 'Append', 'Arc', 'Arctan', 'Array', 
  87.   'Assign', 'AssignCRT', 'Begin', 'Bar', 'Bar3D', 'BlockRead', 'BlockWrite', 
  88.   'Boolean', 'Byte', 'Case', 'Char', 'Chdir', 'Chr', 'Circle', 'ClearDevice', 
  89.   'ClearViewport', 'Close', 'CloseGraph', 'ClrEOL', 'ClrScr', 'Comp', 
  90.   'Concat', 'Const', 'Copy', 'Cos', 'CSeg', 'Dec', 'Delay', 'Delete', 
  91.   'DelLine', 'DetectGraph', 'DiskFree', 'DiskSize', 'Dispose', 'Div', 'Do', 
  92.   'DOSExitCode', 'Double', 'DownTo', 'DrawPoly', 'DSeg', 'Ellipse', 'Else', 
  93.   'End', 'Eof', 'Eoln', 'Erase', 'Exec', 'Exit', 'Exp', 'Extended', 
  94.   'External', 'False', 'File', 'FilePos', 'FileSize', 'FillChar', 'FillPoly', 
  95.   'FindFirst', 'FindNext', 'FloodFill', 'Flush', 'For', 'Forward', 'Frac', 
  96.   'FreeMem', 'Function', 'GetArcCoords', 'GetAspectRatio', 'GetBkColor', 
  97.   'GetColor', 'GetDate', 'GetDir', 'GetFattr', 'GetFillPattern', 
  98.   'GetFillSettings', 'GetFTime', 'GetGraphMode', 'GetImage', 'GetIntVec', 
  99.   'GetLineSettings', 'GetMaxColor', 'GetMaxX', 'GetMaxY', 'GetMem', 
  100.   'GetModeRange', 'GetPallette', 'GetPixel', 'GetTextSettings', 'GetTime', 
  101.   'GetViewSettings', 'GetX', 'GetY', 'Goto', 'GotoXY', 'GraphDefaults', 
  102.   'GraphErrorMesg', 'GraphResult', 'Halt', 'Hi', 'HighVideo', 'If', 
  103.   'ImageSize', 'Implementation', 'In', 'Inc', 'InitGraph', 'InLine', 
  104.   'Insert', 'InsLine', 'Int', 'Integer', 'Interface', 'Interrupt', 'Intr', 
  105.   'IOResult', 'Keep', 'KeyPressed', 'Label', 'Length', 'Line', 'LineRel', 
  106.   'LineTo', 'Ln', 'Lo', 'LongInt', 'LowVideo', 'Mark', 'MaxAvail', 
  107.   'MemAvail', 'MkDir', 'Mod', 'Move', 'MoveRel', 'MoveTo', 'MSDOS', 'New', 
  108.   'Nil', 'NormVideo', 'NoSound', 'Not', 'Odd', 'Of', 'Ofs', 'Or', 'Ord', 
  109.   'OutText', 'OutTextXY', 'Packed', 'PackTime', 'ParamCount', 'ParamStr', 
  110.   'Pi', 'PieSlice', 'Pointer', 'Pos', 'Pred', 'Procedure', 'Program', 'Ptr', 
  111.   'PutImage', 'PutPixel', 'Random', 'Randomize', 'Read', 'ReadKey', 'ReadLn', 
  112.   'Real', 'Record', 'Rectangle', 'RegisterBGIFont', 'RegisterBGIDriver', 
  113.   'Registers', 'Release', 'Rename', 'Repeat', 'Reset', 'RestoreCRTMode', 
  114.   'Rewrite', 'RmDir', 'Round', 'Seek', 'SeekEOF', 'SeekEOLn', 'Seg', 'Set', 
  115.   'SetActivePage', 'SetAllPalette', 'SetBkColor', 'SetColor', 'SetDate', 
  116.   'SetFAttr', 'SetFillPattern', 'SetFillStyle', 'SetFTime', 
  117.   'SetGraphBufSize', 'SetGraphMode', 'SetIntVec', 'SetLineStyle', 
  118.   'SetPalette', 'SetTextBuf', 'SetTextJustify', 'SetTextStyle', 'SetTime', 
  119.   'SetUserCharSize', 'SetViewPort', 'SetVisualPage', 'ShL', 'ShortInt', 
  120.   'ShR', 'Sin', 'Single', 'SizeOf', 'Sound', 'SPtr', 'Sqr', 'Sqrt', 'SSeg', 
  121.   'Str', 'String', 'Succ', 'Swap', 'Text', 'TextBackground', 'TextColor', 
  122.   'TextHeight', 'TextMode', 'TextWidth', 'Then', 'To', 'True', 'Trunc', 
  123.   'Truncate', 'Type', 'Unit', 'UnpackTime', 'Until', 'UpCase', 'Uses', 'Val', 
  124.   'Var', 'WhereX', 'WhereY', 'While', 'Window', 'With', 'Word', 'Write', 
  125.   'WriteLn', 'Xor'
  126.   );
  127.   
  128.   sizebuf = 65520;
  129.   (* If you want to conserve memory at the price of  speed, you  can reduce 
  130.    * sizebuf to any amount down to 1 (not recommended), change  the maximum 
  131.    * index of mybuf to the value sizebuf-1, and recompile the program.
  132.    *)
  133.   
  134. TYPE
  135.   mybuf = ARRAY [0..65519] OF
  136.   CHAR;
  137.   
  138.   KeyNode = RECORD
  139.               character : CHAR;
  140.               index : WORD;
  141.               sibling : POINTER;
  142.               child : POINTER;
  143.             END;
  144.   
  145.   KeyNodePtr = ^KeyNode;
  146.   
  147.   StringPtr = ^STRING;
  148.   
  149.   UserNode = RECORD
  150.                character : CHAR;
  151.                instance : StringPtr;
  152.                sibling : POINTER;
  153.                child : POINTER;
  154.              END;
  155.   
  156.   UserNodePtr = ^UserNode;
  157.   
  158. VAR
  159.   a, b              (* Input and Output buffer pointers *)
  160.   : ^mybuf;
  161.   
  162.   FirstKeyTreeLevel  (* Using more space than absolutely necessary, for speed *)
  163.   : ARRAY [#0..#255] OF
  164.   KeyNode;
  165.   
  166.   FirstUserTreeLevel  (* Using more space than absolutely necessary, for speed *)
  167.   : ARRAY [#0..#255] OF
  168.   UserNode;
  169.   
  170.   IndentationStack
  171.   : ARRAY [0..255] OF
  172.   WORD;
  173.   
  174.   KeyStack
  175.   : ARRAY [0..255] OF
  176.   WORD;
  177.   
  178.   istream, NormalizeKeysToUpperCase, ostream, showbrackcom, showparencom
  179.   : BOOLEAN;
  180.   
  181.   ch, lastch
  182.   : CHAR;
  183.   
  184.   infile, outfile
  185.   : FILE;
  186.   
  187.   i, j, len
  188.   : INTEGER;
  189.   
  190.   HeapPtr
  191.   : POINTER;
  192.   
  193.   ext, filename, iname, CurrentIdentifier, oname, SearchIdent, path, 
  194.   ReplacementIdent, ReplacementUpCaseIdent, s, UpCaseIdent
  195.   : STRING;
  196.   
  197.   UPtr
  198.   : UserNodePtr;
  199.   
  200.   col,  ibegin,  icase,  iconst,  ido, ielse,  iend, ifunction,  iif, ifor, 
  201.   ilabel,  iprocedure,  iprogram, irecord,  irepeat, ithen,  itype, iuntil, 
  202.   ivar, iwhile, iwith, ia, ib, iks,  is, nread, nwrit,  index, index1, iof,
  203.   lastindex
  204.   : WORD;
  205.   
  206. LABEL
  207.   findasterisk, out, start;
  208.   
  209. FUNCTION NewKeyNode (c : CHAR) : KeyNodePtr;
  210. (* Returns a pointer to a newly constructed child-sibling node *)
  211. VAR
  212.   p : KeyNodePtr;
  213. BEGIN
  214.   NEW (p);
  215.   IF (p = NIL) THEN
  216.      BEGIN
  217.      WRITELN ('epb:  out of memory');
  218.      RELEASE (HeapPtr);
  219.      HALT;
  220.      END;
  221.   
  222.   p^.character := c;
  223.   p^.index := 0;
  224.   p^.sibling := NIL;
  225.   p^.child := NIL;
  226.   NewKeyNode := p;
  227. END;
  228.  
  229. FUNCTION NewUserNode (c : CHAR) : UserNodePtr;
  230. (* Returns a pointer to a newly constructed child-sibling node *)
  231. VAR
  232.   p : UserNodePtr;
  233. BEGIN
  234.   NEW (p);
  235.   IF (p = NIL) THEN
  236.      BEGIN
  237.      WRITELN ('epb:  out of memory');
  238.      RELEASE (HeapPtr);
  239.      HALT;
  240.      END;
  241.   
  242.   p^.character := c;
  243.   p^.instance := NIL;
  244.   p^.sibling := NIL;
  245.   p^.child := NIL;
  246.   NewUserNode := p;
  247. END;
  248.  
  249. (* Initialize the first level for the child-sibling trees *)
  250. PROCEDURE InitFirstTreeLevels;
  251. VAR
  252.   i : WORD;
  253.   c : CHAR;
  254. BEGIN
  255.   FOR i := 0 TO 255 DO
  256.       BEGIN
  257.       c := CHR (i);
  258.       
  259.       IF ( (c >= 'A') AND (c <= 'Z') ) OR
  260.          (c = '_') THEN
  261.          FirstKeyTreeLevel [c] .character := c
  262.       ELSE
  263.          FirstKeyTreeLevel [c] .character := ' ';
  264.       
  265.       FirstKeyTreeLevel [c] .index := 0;
  266.       FirstKeyTreeLevel [c] .sibling := NIL;
  267.       FirstKeyTreeLevel [c] .child := NIL;
  268.       
  269.       IF ( (c >= 'A') AND (c <= 'Z') ) OR
  270.          (c = '_') THEN
  271.          FirstUserTreeLevel [c] .character := c
  272.       ELSE
  273.          FirstUserTreeLevel [c] .character := ' ';
  274.       
  275.       FirstUserTreeLevel [c] .instance := NIL;
  276.       FirstUserTreeLevel [c] .sibling := NIL;
  277.       FirstUserTreeLevel [c] .child := NIL;
  278.       END;
  279. END;  (* InitFirstLevels *)
  280.  
  281. PROCEDURE InsertKeyTree (s : STRING;
  282.   slot : INTEGER);
  283.   (* Inserts a string in the Pascal Keyword Tree *)
  284. VAR
  285.   uc : CHAR;
  286.   i, len : WORD;
  287.   p : KeyNodePtr;
  288. LABEL
  289.   loop;
  290. BEGIN
  291.   len := LENGTH (s);
  292.   
  293.   IF (len = 0) THEN  (* There is nothing to insert *)
  294.      EXIT;
  295.   
  296.   uc := UPCASE (s [1]);
  297.   
  298.   IF (uc <> FirstKeyTreeLevel [uc] .character) THEN
  299.      FirstKeyTreeLevel [uc] .character := uc;
  300.   
  301.   IF (len = 1) THEN
  302.      BEGIN
  303.      FirstKeyTreeLevel [uc] .index := slot;
  304.      EXIT;
  305.      END;
  306.   
  307.   i := 2;
  308.   p := FirstKeyTreeLevel [uc] .child;
  309.   
  310.   IF (p = NIL) THEN  (* If the first child does not exist, create it *)
  311.      BEGIN
  312.      p := NewKeyNode (UPCASE (s [2]) );
  313.      FirstKeyTreeLevel [uc] .child := p;
  314.      END;
  315.   
  316.   loop :
  317.   IF (UPCASE (s [i]) = p^.character) THEN
  318.      BEGIN
  319.      IF (i = len) THEN  (* Indicate the termination of the string *)
  320.         BEGIN
  321.         IF (p^.index = 0) THEN
  322.            p^.index := slot;
  323.         EXIT;
  324.         END;
  325.      
  326.      (* Assert: i < len *)
  327.      INC (i);
  328.      IF (p^.child = NIL) THEN
  329.         p^.child := NewKeyNode (UPCASE (s [i]) );
  330.      p := p^.child;
  331.      GOTO loop;
  332.      END
  333.   ELSE
  334.      BEGIN
  335.      IF (p^.sibling = NIL) THEN
  336.         p^.sibling := NewKeyNode (UPCASE (s [i]) );
  337.      p := p^.sibling;
  338.      GOTO loop;
  339.      END;
  340.   
  341. END;  (* InsertKeyTree *)
  342.  
  343.  
  344. FUNCTION SearchKeyTree (s : STRING) : INTEGER;
  345. (* Determines whether or not a string is in the Pascal Keyword Tree *)
  346. (* Returns an index to the keylist[] element on success, a 0 on failure *)
  347. VAR
  348.   i, len : INTEGER;
  349.   p : KeyNodePtr;
  350. LABEL
  351.   loop;
  352.   
  353. BEGIN
  354.   len := LENGTH (s);
  355.   
  356.   IF (len = 0) THEN  (* Should a null string be considered to be present? *)
  357.      BEGIN
  358.      SearchKeyTree := 0;  (* In this program, no *)
  359.      EXIT;
  360.      END;
  361.   
  362.   IF (s [1] <> FirstKeyTreeLevel [s [1] ] .character) THEN
  363.      BEGIN
  364.      SearchKeyTree := 0;  (* Because the length of the string is >= 1 *)
  365.      EXIT;
  366.      END;
  367.   
  368.   IF (len = 1) THEN
  369.      BEGIN
  370.      IF (FirstKeyTreeLevel [s [1] ] .index = 0) THEN
  371.         SearchKeyTree := 0
  372.      ELSE
  373.         SearchKeyTree := FirstKeyTreeLevel [s [1] ] .index;
  374.      EXIT;
  375.      END;
  376.   
  377.   i := 2;
  378.   p := FirstKeyTreeLevel [s [1] ] .child;
  379.   
  380.   IF (p = NIL) THEN
  381.      BEGIN
  382.      SearchKeyTree := 0;  (* Because the tree terminated early *)
  383.      EXIT;
  384.      END;
  385.   
  386.   loop :
  387.   IF (s [i] = p^.character) THEN
  388.      BEGIN
  389.      IF (i = len) THEN  (* Stop searching *)
  390.         BEGIN
  391.         IF (p^.index = 0) THEN
  392.            SearchKeyTree := 0
  393.         ELSE
  394.            SearchKeyTree := p^.index;
  395.         EXIT;
  396.         END;
  397.      
  398.      (* Assert: i < len *)
  399.      p := p^.child;
  400.      IF (p = NIL) THEN
  401.         BEGIN
  402.         SearchKeyTree := 0;  (* Because the tree terminated early *)
  403.         EXIT;
  404.         END;
  405.      INC (i);
  406.      GOTO loop;
  407.      END
  408.   ELSE
  409.      BEGIN
  410.      p := p^.sibling;
  411.      IF (p = NIL) THEN
  412.         BEGIN
  413.         SearchKeyTree := 0;  (* Because the tree terminated early *)
  414.         EXIT;
  415.         END;
  416.      GOTO loop;
  417.      END;
  418.   
  419. END;  (* SearchKeyTree *)
  420.  
  421.  
  422. PROCEDURE InsertUserTree (s : STRING);
  423.   (* Inserts a string in the User Identifier Tree *)
  424. VAR
  425.   uc : CHAR;
  426.   i, len : WORD;
  427.   p : UserNodePtr;
  428. LABEL loop;
  429. BEGIN
  430.   len := LENGTH (s);
  431.   
  432.   IF (len = 0) THEN  (* There is nothing to insert *)
  433.      EXIT;
  434.   
  435.   uc := UPCASE (s [1]);
  436.   
  437.   IF (uc <> FirstUserTreeLevel [uc] .character) THEN
  438.      FirstUserTreeLevel [uc] .character := uc;
  439.   
  440.   IF (len = 1) THEN
  441.      BEGIN
  442.      GETMEM (FirstUserTreeLevel [uc] .instance, 2);  (* 1 for the length indicator, 1 for the string *)
  443.      FirstUserTreeLevel [uc] .instance^ := s;
  444.      EXIT;
  445.      END;
  446.   
  447.   i := 2;
  448.   p := FirstUserTreeLevel [uc] .child;
  449.   
  450.   IF (p = NIL) THEN  (* If the first child does not exist, create it *)
  451.      BEGIN
  452.      p := NewUserNode (UPCASE (s [2]) );
  453.      FirstUserTreeLevel [uc] .child := p;
  454.      END;
  455.   
  456.   loop :
  457.   IF (UPCASE (s [i]) = p^.character) THEN
  458.      BEGIN
  459.      IF (i = len) THEN  (* Indicate the termination of the string *)
  460.         BEGIN
  461.         IF (p^.instance = NIL) THEN
  462.            BEGIN
  463.            GETMEM (p^.instance, 1 + len);
  464.            p^.instance^ := s;
  465.            END;
  466.         EXIT;
  467.         END;
  468.      
  469.      (* Assert: i < len *)
  470.      INC (i);
  471.      IF (p^.child = NIL) THEN
  472.         p^.child := NewUserNode (UPCASE (s [i]) );
  473.      p := p^.child;
  474.      GOTO loop;
  475.      END
  476.   ELSE
  477.      BEGIN
  478.      IF (p^.sibling = NIL) THEN
  479.         p^.sibling := NewUserNode (UPCASE (s [i]) );
  480.      p := p^.sibling;
  481.      GOTO loop;
  482.      END;
  483.   
  484. END;  (* InsertUserTree *)
  485.  
  486.  
  487. FUNCTION SearchUserTree (s : STRING) : UserNodePtr;
  488. (* Determines whether or not a string is in the User Identifier Tree *)
  489. (* Returns a pointer to the final node on success, a NIL pointer on failure *)
  490. VAR
  491.   i, len : INTEGER;
  492.   p : UserNodePtr;
  493. LABEL
  494.   loop;
  495. BEGIN
  496.   len := LENGTH (s);
  497.   
  498.   IF (len = 0) THEN  (* Should a null string be considered to be present? *)
  499.      BEGIN
  500.      SearchUserTree := NIL;  (* In this program, no *)
  501.      EXIT;
  502.      END;
  503.   
  504.   IF (s [1] <> FirstUserTreeLevel [s [1] ] .character) THEN
  505.      BEGIN
  506.      SearchUserTree := NIL;  (* Because the length of the string is >= 1 *)
  507.      EXIT;
  508.      END;
  509.   
  510.   IF (len = 1) THEN
  511.      BEGIN
  512.      IF (FirstUserTreeLevel [s [1] ] .instance = NIL) THEN
  513.         SearchUserTree := NIL
  514.      ELSE
  515.         SearchUserTree := @FirstUserTreeLevel [s [1] ];
  516.      EXIT;
  517.      END;
  518.   
  519.   i := 2;
  520.   p := FirstUserTreeLevel [s [1] ] .child;
  521.   
  522.   IF (p = NIL) THEN
  523.      BEGIN
  524.      SearchUserTree := NIL;  (* Because the tree terminated early *)
  525.      EXIT;
  526.      END;
  527.   
  528.   loop :
  529.   IF (s [i] = p^.character) THEN
  530.      BEGIN
  531.      IF (i = len) THEN  (* Stop searching *)
  532.         BEGIN
  533.         IF (p^.instance = NIL) THEN
  534.            SearchUserTree := NIL
  535.         ELSE
  536.            SearchUserTree := p;
  537.         EXIT;
  538.         END;
  539.      
  540.      (* Assert: i < len *)
  541.      p := p^.child;
  542.      IF (p = NIL) THEN
  543.         BEGIN
  544.         SearchUserTree := NIL;  (* Because the tree terminated early *)
  545.         EXIT;
  546.         END;
  547.      INC (i);
  548.      GOTO loop;
  549.      END
  550.   ELSE
  551.      BEGIN
  552.      p := p^.sibling;
  553.      IF (p = NIL) THEN
  554.         BEGIN
  555.         SearchUserTree := NIL;  (* Because the tree terminated early *)
  556.         EXIT;
  557.         END;
  558.      GOTO loop;
  559.      END;
  560.   
  561. END;  (* SearchUserTree *)
  562.  
  563.  
  564. {$F+}
  565. FUNCTION HeapFunc (size : WORD) : INTEGER; {$F-}
  566. BEGIN
  567.   HeapFunc := 1;  (* Make NEW return a NIL pointer when out of memory *)
  568. END;
  569.  
  570. PROCEDURE PushIndent (indent : WORD);
  571. BEGIN
  572.   IF (is < 256) THEN
  573.      BEGIN
  574.      INC (is);
  575.      IndentationStack [is] := IndentationStack [is - 1] + indent;
  576.      END;
  577. END;
  578.  
  579. PROCEDURE PopIndent;
  580. BEGIN
  581.   IF (is > 0) THEN
  582.      DEC (is);
  583. END;
  584.  
  585. PROCEDURE PushKey (key : WORD);
  586. BEGIN
  587.   IF (iks < 256) THEN
  588.      BEGIN
  589.      INC (iks);
  590.      KeyStack [iks] := key;
  591.      END;
  592. END;
  593.  
  594. PROCEDURE PopKey;
  595. BEGIN
  596.   IF (iks > 0) THEN
  597.      DEC (iks);
  598. END;
  599.  
  600. PROCEDURE writeblock;
  601. BEGIN
  602.   BLOCKWRITE (outfile, b^, ib, nwrit);
  603.   
  604.   IF (nwrit <> ib) AND (oname <> '') THEN  (* Don't check output to STDOUT *)
  605.      BEGIN
  606.      WRITELN ('epb:  Cannot finish outputting (out of disk space?)');
  607.      CLOSE (outfile);
  608.      RELEASE (HeapPtr);
  609.      HALT;
  610.      END;
  611.   
  612.   ib := 0;
  613. END;  (* writeblock *)
  614.  
  615. PROCEDURE getblock;
  616. BEGIN
  617.   ia := 0;
  618.   BLOCKREAD (infile, a^, sizebuf, nread);
  619.   
  620.   IF (nread = 0) THEN
  621.      BEGIN
  622.      writeblock;
  623.      CLOSE (infile);
  624.      RELEASE (HeapPtr);
  625.      HALT;
  626.      END;
  627. END;  (* getblock *)
  628.  
  629. PROCEDURE OutPaddedChar (c : CHAR);  (* Output a character, possibly w/ padding *)
  630. BEGIN
  631.   CASE c OF
  632.        '[', '(', '<', '+', '/', '*', '-', ':' :
  633.        IF (lastch <> #32) THEN
  634.           BEGIN
  635.           b^ [ib] := #32;
  636.           INC (ib);
  637.           IF (ib = sizebuf) THEN
  638.              writeblock;
  639.           INC (col);
  640.           END;
  641.        
  642.        '=' :
  643.        IF (lastch > #32) AND
  644.           (lastch <> ':') AND (lastch <> '<') AND (lastch <> '>') THEN
  645.           BEGIN
  646.           b^ [ib] := #32;
  647.           INC (ib);
  648.           IF (ib = sizebuf) THEN
  649.              writeblock;
  650.           INC (col);
  651.           END;
  652.        
  653.        '>' :
  654.        IF (lastch > #32) AND
  655.           (lastch <> '<') THEN
  656.           BEGIN
  657.           b^ [ib] := #32;
  658.           INC (ib);
  659.           IF (ib = sizebuf) THEN
  660.              writeblock;
  661.           INC (col);
  662.           END;
  663.        
  664.        ')' :
  665.        IF (lastch = ')') THEN
  666.           BEGIN
  667.           b^ [ib] := #32;
  668.           INC (ib);
  669.           IF (ib = sizebuf) THEN
  670.              writeblock;
  671.           INC (col);
  672.           END;
  673.        
  674.   ELSE  (* case c *)
  675.        
  676.        IF (c > #32) THEN
  677.           CASE lastch OF
  678.                ':' :
  679.                IF (c <> '=') THEN
  680.                   BEGIN
  681.                   b^ [ib] := #32;
  682.                   INC (ib);
  683.                   IF (ib = sizebuf) THEN
  684.                      writeblock;
  685.                   INC (col);
  686.                   END;
  687.                
  688.                '<' :
  689.                IF (c <> '>') AND (c <> '=') THEN
  690.                   BEGIN
  691.                   b^ [ib] := #32;
  692.                   INC (ib);
  693.                   IF (ib = sizebuf) THEN
  694.                      writeblock;
  695.                   INC (col);
  696.                   END;
  697.                
  698.                '>' :
  699.                IF (c <> '=') THEN
  700.                   BEGIN
  701.                   b^ [ib] := #32;
  702.                   INC (ib);
  703.                   IF (ib = sizebuf) THEN
  704.                      writeblock;
  705.                   INC (col);
  706.                   END;
  707.                
  708.                ')' :
  709.                IF (c <> ';') AND (c <> ',') THEN
  710.                   BEGIN
  711.                   b^ [ib] := #32;
  712.                   INC (ib);
  713.                   IF (ib = sizebuf) THEN
  714.                      writeblock;
  715.                   INC (col);
  716.                   END;
  717.                
  718.                '=', '+', '/', '*', '-', ',' :
  719.                BEGIN
  720.                b^ [ib] := #32;
  721.                INC (ib);
  722.                IF (ib = sizebuf) THEN
  723.                   writeblock;
  724.                INC (col);
  725.                END;
  726.                
  727.                ']' :
  728.                IF (c <> ')') AND (c <> ';') AND (c <> ',') AND (c <> '^') THEN
  729.                   BEGIN
  730.                   b^ [ib] := #32;
  731.                   INC (ib);
  732.                   IF (ib = sizebuf) THEN
  733.                      writeblock;
  734.                   INC (col);
  735.                   END;
  736.                
  737.           END;  (* case lastch *)
  738.   END;  (* case c *)
  739.   
  740.   b^ [ib] := c;
  741.   INC (ib);
  742.   IF (ib = sizebuf) THEN
  743.      writeblock;
  744.   INC (col);
  745.   lastch := c;
  746. END;  (* OutPaddedChar *)
  747.  
  748. PROCEDURE OutLiteralChar (c : CHAR);  (* Output a character without padding *)
  749. BEGIN
  750.   b^ [ib] := c;
  751.   INC (ib);
  752.   IF (ib = sizebuf) THEN
  753.      writeblock;
  754.   INC (col);
  755.   lastch := c;
  756. END;  (* OutLiteralChar *)
  757.  
  758. PROCEDURE OutIdent (s : STRING);  (* Output an identifier *)
  759. VAR
  760.   i, len
  761.   : INTEGER;
  762. BEGIN
  763.   len := LENGTH (s);
  764.   IF (len <> 0) THEN
  765.      OutPaddedChar (s [1]);
  766.   
  767.   FOR i := 2 TO len DO
  768.       BEGIN
  769.       b^ [ib] := s [i];
  770.       INC (ib);
  771.       IF (ib = sizebuf) THEN
  772.          writeblock;
  773.       INC (col);
  774.       END;
  775.   
  776.   lastch := s [len];
  777. END;  (* OutIdent *)
  778.  
  779. (* Split up a Path, Filename, Extension string *)
  780. PROCEDURE SplitPFE (pf : STRING;
  781. VAR p : STRING;
  782. VAR f : STRING;
  783. VAR e : STRING);
  784. VAR i : INTEGER;
  785. BEGIN
  786.   p := '';
  787.   f := '';
  788.   e := '';
  789.   i := LENGTH (pf);
  790.   
  791.   WHILE ( (POS (COPY (pf, i, 1), ':/\') = 0) AND (i > 0) ) DO
  792.         DEC (i);
  793.   
  794.   p := COPY (pf, 1, i);
  795.   f := COPY (pf, i + 1, 255);
  796.   
  797.   i := POS ('.', f);
  798.   
  799.   IF (i > 0) THEN
  800.      BEGIN
  801.      e := COPY (f, i + 1, 3);
  802.      f := COPY (f, 1, i);
  803.      END;
  804. END;
  805.  
  806. PROCEDURE breakline;
  807. BEGIN
  808.   b^ [ib] := #13;
  809.   INC (ib);
  810.   IF (ib = sizebuf) THEN
  811.      writeblock;
  812.   b^ [ib] := #10;
  813.   INC (ib);
  814.   IF (ib = sizebuf) THEN
  815.      writeblock;
  816.   lastch := #10;
  817.   col := 0;
  818. END;
  819.  
  820. PROCEDURE skipwhitespace;
  821. BEGIN
  822.   WHILE (a^ [ia] < #33) DO
  823.         BEGIN
  824.         INC (ia);
  825.         IF (ia >= nread) THEN
  826.            getblock;
  827.         END;
  828. END;  (* skipwhitespace *)
  829.  
  830. PROCEDURE skipspace;
  831. BEGIN
  832.   WHILE (a^ [ia] < #33) AND (a^ [ia] <> #13) AND (a^ [ia] <> #10) DO
  833.         BEGIN
  834.         INC (ia);
  835.         IF (ia >= nread) THEN
  836.            getblock;
  837.         END;
  838. END;  (* skipspace *)
  839.  
  840. PROCEDURE indent;
  841. VAR i : WORD;
  842. BEGIN
  843.   FOR i := 1 TO IndentationStack [is] DO
  844.       BEGIN
  845.       b^ [ib] := #32;
  846.       INC (ib);
  847.       IF (ib = sizebuf) THEN
  848.          writeblock;
  849.       END;
  850.   
  851.   IF (IndentationStack [is] <> 0) THEN  (* Keep track of the current column *)
  852.      BEGIN
  853.      col := col + IndentationStack [is];
  854.      lastch := #32;
  855.      END;
  856. END;  (* indent *)
  857.  
  858. PROCEDURE condbreakline;
  859. VAR
  860.   ch : CHAR;
  861.   s : STRING;
  862.   i, len : WORD;
  863. BEGIN
  864.   ch := a^ [ia];
  865.   IF (ch <> #13) THEN
  866.      BEGIN
  867.      s := '';
  868.      WHILE (a^ [ia] < #33) AND (a^ [ia] <> #13) AND (a^ [ia] <> #10) DO
  869.            BEGIN
  870.            s := s + a^ [ia];  (* Save spaces *)
  871.            INC (ia);
  872.            IF (ia >= nread) THEN
  873.               getblock;
  874.            END;
  875.      len := LENGTH (s);
  876.      ch := a^ [ia];
  877.      IF (ch = '(') OR (ch = '{') THEN
  878.         FOR i := 1 TO len DO  (* Write saved spaces *)
  879.             BEGIN
  880.             b^ [ib] := s [i];
  881.             INC (ib);
  882.             IF (ib = sizebuf) THEN
  883.                writeblock;
  884.             INC (col);
  885.             END
  886.      ELSE
  887.         breakline;
  888.      END;
  889. END;  (* condbreakline *)
  890.  
  891. {---- MAIN PROGRAM ----}
  892. BEGIN
  893.   IF (PARAMCOUNT = 0) THEN
  894.      BEGIN
  895.      WRITELN (#10'ED''S PASCAL BEAUTIFIER v2.33, Copyright 1992 by Edward Lee, -Ed L');
  896.      WRITELN ('edlee@chinet.chi.il.us       THIS PROGRAM MAY NOT BE DISTRIBUTED FOR PROFIT');
  897.      WRITELN (#10'EPB normalizes  the indentation  of (Turbo)  Pascal source  code, including');
  898.      WRITELN ('nested  IF  THEN  ELSE  constructs,  and  normalizes the  capitalization of');
  899.      WRITELN ('(Turbo) Pascal identifiers to either upper case or  mixed case,  defaulting');
  900.      WRITELN ('to upper  case.  Each  non-(Turbo) Pascal identifier has its capitalization');
  901.      WRITELN ('normalized  to  the way  it first  appears in  the input  stream.  EPB  can');
  902.      WRITELN ('do identifier substitutions by ignoring comments, sub-strings, and  literal');
  903.      WRITELN ('strings. An input file, if specified, is renamed to *.BAK before execution.');
  904.      WRITELN ('This program, EPB, is provided without warranty.  Use EPB at your own risk.');
  905.      WRITELN (#10'INVOCATION (items in brackets are optional):');
  906.      WRITELN ('  epb [-bimop] [InputFile[.PAS]] [OutputFile[.PAS]] [-s Original Replacement]');
  907.      WRITELN (#10'OPTIONS (flexible in case, grouping, and positioning on the command line):');
  908.      WRITELN (' -b  Shut off the output of Bracket comments:  { ... }');
  909.      WRITELN (' -p  Shut off the output of Parentheses comments:  (* ... *)');
  910.      WRITELN (' -i  Use the standard Input  (STDIN)  stream for input  instead of InputFile');
  911.      WRITELN (' -o  Use the standard Output (STDOUT) stream for output instead of OutputFile');
  912.      WRITELN (' -m  Normalize all keywords to Mixed case rather than the default upper case');
  913.      WRITELN (' -s  Substitute all occurrences of an Original identifier with a Replacement');
  914.      HALT;
  915.      END;
  916.   
  917.   InitFirstTreeLevels;
  918.   
  919.   (* Copy keylist[] in a normalized form to the Key Tree *)
  920.   FOR i := 1 TO nkeys DO
  921.       InsertKeyTree (keylist [i], i);
  922.   
  923.   showparencom := TRUE;
  924.   showbrackcom := TRUE;
  925.   istream := FALSE;
  926.   ostream := FALSE;
  927.   NormalizeKeysToUpperCase := TRUE;
  928.   
  929.   SearchIdent := '';
  930.   ReplacementIdent := '';
  931.   ReplacementUpCaseIdent := '';
  932.   
  933.   i := 0;
  934.   WHILE (i < PARAMCOUNT) DO    (* Process options *)
  935.         BEGIN
  936.         INC (i);
  937.         s := PARAMSTR (i);
  938.         IF (s [1] = '-') THEN
  939.            BEGIN
  940.            IF (POS ('b', s) > 0) OR (POS ('B', s) > 0) THEN
  941.               showbrackcom := FALSE;
  942.            IF (POS ('p', s) > 0) OR (POS ('P', s) > 0) THEN
  943.               showparencom := FALSE;
  944.            IF (POS ('i', s) > 0) OR (POS ('I', s) > 0) THEN
  945.               istream := TRUE;
  946.            IF (POS ('o', s) > 0) OR (POS ('O', s) > 0) THEN
  947.               ostream := TRUE;
  948.            IF (POS ('m', s) > 0) OR (POS ('M', s) > 0) THEN
  949.               NormalizeKeysToUpperCase := FALSE;
  950.            IF (POS ('s', s) > 0) OR (POS ('S', s) > 0) THEN
  951.               BEGIN
  952.               INC (i);
  953.               SearchIdent := PARAMSTR (i);
  954.               INC (i);
  955.               ReplacementIdent := PARAMSTR (i);
  956.               IF (i > PARAMCOUNT) THEN
  957.                  BEGIN
  958.                  WRITELN ('epb:  Error.  The -s option has been used without enough parameters.');
  959.                  HALT;
  960.                  END;
  961.               END;  (* if (pos ('s' ... *)
  962.            END;  (* if (s [1] ... *)
  963.         END;  (* while *)
  964.   
  965.   (* Normalize Original and Replacement strings via upper case function *)
  966.   FOR i := 1 TO LENGTH (SearchIdent) DO
  967.       SearchIdent [i] := UPCASE (SearchIdent [i]);
  968.   
  969.   FOR i := 1 TO LENGTH (ReplacementIdent) DO
  970.       ReplacementUpCaseIdent := ReplacementUpCaseIdent + UPCASE (ReplacementIdent [i]);
  971.   
  972.   iname := '';
  973.   oname := '';
  974.   
  975.   IF NOT (istream AND ostream) THEN
  976.      BEGIN
  977.      i := 0;
  978.      WHILE (i < PARAMCOUNT) DO    (* Get filename(s) *)
  979.            BEGIN
  980.            INC (i);
  981.            s := PARAMSTR (i);
  982.            
  983.            IF (s [1] <> '-') THEN   (* Skip option flags *)
  984.               BEGIN
  985.               IF (istream) THEN     (* Input is from STDIN *)
  986.                  BEGIN
  987.                  oname := s;
  988.                  GOTO out;
  989.                  END
  990.               ELSE
  991.                  IF (ostream) THEN     (* Output is to STDOUT *)
  992.                     BEGIN
  993.                     iname := s;
  994.                     GOTO out;
  995.                     END
  996.                  ELSE
  997.                     IF (iname = '') THEN  (* Input is from infile *)
  998.                        iname := s
  999.                     ELSE
  1000.                        BEGIN
  1001.                        oname := s;        (* Output is to outfile *)
  1002.                        GOTO out;
  1003.                        END;
  1004.               END  (* if (s [1] ... *)
  1005.            
  1006.            ELSE
  1007.               
  1008.               IF (POS ('s', s) > 0) OR (POS ('S', s) > 0) THEN
  1009.                  i := i + 2;
  1010.            
  1011.            END;  (* while *)
  1012.      END;  (* if not *)
  1013.   
  1014.   out :
  1015.   SplitPFE (iname, path, filename, ext);
  1016.   
  1017.   IF (filename <> '') THEN
  1018.      IF (COPY (filename, LENGTH (filename), 1) <> '.') THEN
  1019.         BEGIN
  1020.         filename := filename + '.';
  1021.         iname := path + filename + 'PAS';
  1022.         END;
  1023.   
  1024.   s := path + filename + 'BAK';
  1025.   
  1026.   SplitPFE (oname, path, filename, ext);
  1027.   
  1028.   IF (filename <> '') THEN
  1029.      IF (COPY (filename, LENGTH (filename), 1) <> '.') THEN
  1030.         oname := path + filename + '.PAS';
  1031.   
  1032.   IF (iname <> '') THEN
  1033.      IF (iname = oname) OR
  1034.         ( (oname = '') AND NOT ostream) THEN
  1035.         BEGIN
  1036.         ASSIGN (infile, s);  (* If a backup file already exists, erase it *)
  1037.         {$I-}
  1038.         RESET (infile, 1); {$I+}
  1039.         IF (IORESULT = 0) THEN
  1040.            BEGIN
  1041.            CLOSE (infile);
  1042.            ERASE (infile);
  1043.            END;
  1044.         
  1045.         ASSIGN (infile, iname);
  1046.         {$I-}
  1047.         RESET (infile, 1); {$I+}
  1048.         IF (IORESULT = 0) THEN
  1049.            BEGIN
  1050.            CLOSE (infile);
  1051.            RENAME (infile, s);
  1052.            END
  1053.         ELSE
  1054.            BEGIN
  1055.            WRITELN ('epb:  Cannot rename original file, ', iname, ', to ', s, '.');
  1056.            HALT;
  1057.            END;
  1058.         
  1059.         oname := iname;
  1060.         iname := s;
  1061.         END;
  1062.   
  1063.   ASSIGN (infile, iname);
  1064.   {$I-}
  1065.   RESET (infile, 1); {$I+}
  1066.   IF (IORESULT <> 0) THEN
  1067.      BEGIN
  1068.      WRITELN ('epb:  Cannot open input file, ', iname);
  1069.      HALT;
  1070.      END;
  1071.   
  1072.   ASSIGN (outfile, oname);
  1073.   {$I-}
  1074.   REWRITE (outfile, 1); {$I+}
  1075.   IF (IORESULT <> 0) THEN
  1076.      BEGIN
  1077.      WRITELN ('epb:  Error opening output file, ', oname, '.  DOS file limit reached?');
  1078.      HALT;
  1079.      END;
  1080.   
  1081.   HeapError := @HeapFunc;
  1082.   
  1083.   MARK (HeapPtr);
  1084.   
  1085.   NEW (a);
  1086.   NEW (b);
  1087.   getblock;
  1088.   
  1089.   IF (a = NIL) OR (b = NIL) THEN
  1090.      BEGIN
  1091.      WRITELN ('epb: There is not enough free conventional memory for epb to run.');
  1092.      RELEASE (HeapPtr);
  1093.      HALT;
  1094.      END;
  1095.   
  1096.   col := 0;
  1097.   ib := 0;
  1098.   iks := 0;
  1099.   KeyStack [iks] := 0;
  1100.   is := 0;
  1101.   IndentationStack [is] := 0;
  1102.   index := 0;
  1103.   lastch := #0;
  1104.   CurrentIdentifier := '';
  1105.   UpCaseIdent := '';
  1106.   
  1107.   (* Soft-coded indexes to some keywords of interest *)
  1108.   ibegin := SearchKeyTree ('BEGIN');
  1109.   icase := SearchKeyTree ('CASE');
  1110.   iconst := SearchKeyTree ('CONST');
  1111.   ido := SearchKeyTree ('DO');
  1112.   iend := SearchKeyTree ('END');
  1113.   ifor := SearchKeyTree ('FOR');
  1114.   ifunction := SearchKeyTree ('FUNCTION');
  1115.   iif := SearchKeyTree ('IF');
  1116.   ithen := SearchKeyTree ('THEN');
  1117.   ielse := SearchKeyTree ('ELSE');
  1118.   ilabel := SearchKeyTree ('LABEL');
  1119.   iof := SearchKeyTree ('OF');
  1120.   iprocedure := SearchKeyTree ('PROCEDURE');
  1121.   iprogram := SearchKeyTree ('PROGRAM');
  1122.   irecord := SearchKeyTree ('RECORD');
  1123.   irepeat := SearchKeyTree ('REPEAT');
  1124.   itype := SearchKeyTree ('TYPE');
  1125.   iuntil := SearchKeyTree ('UNTIL');
  1126.   ivar := SearchKeyTree ('VAR');
  1127.   iwhile := SearchKeyTree ('WHILE');
  1128.   iwith := SearchKeyTree ('WITH');
  1129.   
  1130.   skipwhitespace;
  1131.   PushKey (iprogram);
  1132.   
  1133.   start :
  1134.   ch := a^ [ia];
  1135.   
  1136.   IF (lastch = #10) THEN
  1137.      
  1138.      BEGIN
  1139.      col := 0;
  1140.      skipspace;
  1141.      ch := a^ [ia];
  1142.      IF ( (ch < 'A') OR (ch > 'Z') ) AND
  1143.         ( (ch < 'a') OR (ch > 'z') ) AND
  1144.         (ch <> '_') THEN
  1145.         indent;
  1146.      END;
  1147.   
  1148.   CASE ch OF
  1149.        ';' :
  1150.        BEGIN
  1151.        OutLiteralChar (ch);
  1152.        INC (ia);
  1153.        IF (ia >= nread) THEN
  1154.           getblock;
  1155.        IF (KeyStack [iks] = iuntil) THEN
  1156.           BEGIN
  1157.           PopIndent;
  1158.           PopKey;
  1159.           END;
  1160.        
  1161.        condbreakline;
  1162.        
  1163.        WHILE (KeyStack [iks] = ido) DO
  1164.              BEGIN
  1165.              PopIndent;
  1166.              PopKey;
  1167.              END;
  1168.        
  1169.        WHILE (KeyStack [iks] = ithen) OR (KeyStack [iks] = ielse) DO
  1170.              BEGIN
  1171.              PopIndent;
  1172.              PopKey;
  1173.              END;
  1174.        
  1175.        GOTO start;
  1176.        END;  (* ';' *)
  1177.        
  1178.        
  1179.        #39 :   (* Do not process the contents of literal strings *)
  1180.        BEGIN
  1181.        OutPaddedChar (a^ [ia]);
  1182.        INC (ia);
  1183.        IF (ia >= nread) THEN
  1184.           getblock;
  1185.        WHILE (a^ [ia] <> #39) DO
  1186.              BEGIN
  1187.              OutLiteralChar (a^ [ia]);
  1188.              INC (ia);
  1189.              IF (ia >= nread) THEN
  1190.                 getblock;
  1191.              END;
  1192.        OutLiteralChar (a^ [ia]);
  1193.        INC (ia);
  1194.        IF (ia >= nread) THEN
  1195.           getblock;
  1196.        GOTO start;
  1197.        END;  (* ' *)
  1198.        
  1199.        
  1200.        '{' :   (* Do not process the contents of { ... } comments *)
  1201.        BEGIN
  1202.        IF (showbrackcom) THEN
  1203.           BEGIN
  1204.           OutLiteralChar (a^ [ia]);
  1205.           INC (ia);
  1206.           IF (ia >= nread) THEN
  1207.              getblock;
  1208.           WHILE (a^ [ia] <> '}') DO
  1209.                 BEGIN
  1210.                 OutLiteralChar (a^ [ia]);
  1211.                 INC (ia);
  1212.                 IF (ia >= nread) THEN
  1213.                    getblock;
  1214.                 END;
  1215.           OutLiteralChar (a^ [ia]);
  1216.           INC (ia);
  1217.           IF (ia >= nread) THEN
  1218.              getblock;
  1219.           END
  1220.        ELSE
  1221.           BEGIN
  1222.           INC (ia);
  1223.           IF (ia >= nread) THEN
  1224.              getblock;
  1225.           WHILE (a^ [ia] <> '}') DO
  1226.                 BEGIN
  1227.                 INC (ia);
  1228.                 IF (ia >= nread) THEN
  1229.                    getblock;
  1230.                 END;
  1231.           INC (ia);
  1232.           IF (ia >= nread) THEN
  1233.              getblock;
  1234.           END;
  1235.        IF (a^ [ia] <> #13) THEN
  1236.           BEGIN
  1237.           breakline;
  1238.           skipspace;
  1239.           END;
  1240.        GOTO start;
  1241.        END;  (* {} *)
  1242.        
  1243.        
  1244.        '(' :   { Do not process the contents of (* ... *) comments }
  1245.        BEGIN
  1246.        INC (ia);
  1247.        IF (ia >= nread) THEN
  1248.           getblock;
  1249.        IF (a^ [ia] <> '*') THEN
  1250.           BEGIN
  1251.           OutPaddedChar (ch);
  1252.           GOTO start;
  1253.           END
  1254.        ELSE   (* A comment has begun *)
  1255.           BEGIN
  1256.           IF (showparencom) THEN
  1257.              BEGIN
  1258.              OutLiteralChar (ch);
  1259.              OutLiteralChar (a^ [ia]);
  1260.              END;
  1261.           
  1262.           INC (ia);
  1263.           IF (ia >= nread) THEN
  1264.              getblock;
  1265.           IF (showparencom) THEN
  1266.              OutLiteralChar (a^ [ia]);
  1267.           
  1268.           findasterisk :
  1269.           WHILE (a^ [ia] <> '*') DO
  1270.                 BEGIN
  1271.                 INC (ia);
  1272.                 IF (ia >= nread) THEN
  1273.                    getblock;
  1274.                 IF (showparencom) THEN
  1275.                    OutLiteralChar (a^ [ia]);
  1276.                 END;  (* a^[ia] = '*' *)
  1277.           
  1278.           INC (ia);
  1279.           IF (ia >= nread) THEN
  1280.              getblock;
  1281.           IF (showparencom) THEN
  1282.              OutLiteralChar (a^ [ia]);
  1283.           
  1284.           IF (a^ [ia] <> ')') THEN
  1285.              GOTO findasterisk;
  1286.           INC (ia);
  1287.           IF (ia >= nread) THEN
  1288.              getblock;
  1289.           IF (a^ [ia] <> #13) THEN
  1290.              BEGIN
  1291.              breakline;
  1292.              skipspace;
  1293.              END;
  1294.           GOTO start;
  1295.           END;
  1296.        END;  { (* *) }
  1297.        
  1298.        
  1299.        'A'..'Z', 'a'..'z', '_' :  (* Collect and process identifiers *)
  1300.        BEGIN
  1301.        REPEAT
  1302.          UpCaseIdent := UpCaseIdent + UPCASE (ch);
  1303.          CurrentIdentifier := CurrentIdentifier + ch;
  1304.          INC (ia);
  1305.          IF (ia >= nread) THEN
  1306.             getblock;
  1307.          ch := a^ [ia];
  1308.        UNTIL ( (ch < 'A') OR (ch > 'Z') ) AND
  1309.              ( (ch < 'a') OR (ch > 'z') ) AND
  1310.              ( (ch < '0') OR (ch > '9') ) AND
  1311.              (ch <> '_');  {Turbo Pascal Sets are too slow}
  1312.        
  1313.        (*
  1314. if (upcaseident = 'FOOZ') then
  1315.    begin
  1316.    writeln('{');
  1317.    writeln('iks = ', iks);
  1318.    writeln('keystack[iks] = ', keystack[iks]);
  1319.    if (keystack[iks] > 0) then
  1320.       writeln('keylist[keystack[iks]] = ', keylist[keystack[iks]]);
  1321.    writeln('is = ', is);
  1322.    writeln('indentationstack[is] = ', indentationstack[is]);
  1323.    writeln('col = ', col);
  1324.    writeln('}');
  1325.    end;
  1326. *)
  1327.        
  1328.        IF (UpCaseIdent = SearchIdent) THEN
  1329.           BEGIN
  1330.           UpCaseIdent := ReplacementUpCaseIdent;
  1331.           CurrentIdentifier := ReplacementIdent;
  1332.           END;
  1333.        
  1334.        lastindex := index;
  1335.        
  1336.        index := SearchKeyTree (UpCaseIdent);
  1337.        
  1338.        IF (index = iend) THEN
  1339.           BEGIN
  1340.           PopIndent;
  1341.           IF (KeyStack [iks] = icase) THEN
  1342.              BEGIN
  1343.              PopKey;
  1344.              IF (KeyStack [iks] = irecord) THEN
  1345.                 PopIndent;
  1346.              END;
  1347.           END
  1348.        ELSE
  1349.           IF (index = iuntil) THEN
  1350.              BEGIN
  1351.              PopIndent;
  1352.              PopKey;
  1353.              END
  1354.           ELSE
  1355.              IF (index = ielse) AND (KeyStack [iks] = icase) THEN
  1356.                 PopIndent
  1357.              ELSE
  1358.                 IF (KeyStack [iks] = iprogram) OR
  1359.                    (KeyStack [iks] = iprocedure) OR
  1360.                    (KeyStack [iks] = ifunction) THEN
  1361.                    BEGIN
  1362.                    IF (index = ivar) OR
  1363.                       (index = iconst) OR
  1364.                       (index = itype) OR
  1365.                       (index = iprocedure) OR
  1366.                       (index = ifunction) OR
  1367.                       (index = ilabel) THEN
  1368.                       PopIndent
  1369.                    ELSE
  1370.                       IF (index = ibegin) THEN
  1371.                          BEGIN
  1372.                          PopIndent;
  1373.                          PopKey;
  1374.                          END;
  1375.                    END;
  1376.        
  1377.        IF (lastch = #10) THEN
  1378.           indent;
  1379.        
  1380.        (* Output Identifier *)
  1381.        IF (index <> 0) THEN
  1382.           IF (NormalizeKeysToUpperCase) THEN
  1383.              OutIdent (UpCaseIdent)
  1384.           ELSE
  1385.              OutIdent (keylist [index])
  1386.        ELSE
  1387.           BEGIN
  1388.           UPtr := SearchUserTree (UpCaseIdent);
  1389.           
  1390.           IF (UPtr <> NIL) THEN
  1391.              OutIdent (UPtr^.instance^)
  1392.           ELSE
  1393.              BEGIN
  1394.              InsertUserTree (CurrentIdentifier);
  1395.              OutIdent (CurrentIdentifier);
  1396.              END;
  1397.           END;
  1398.        
  1399.        IF (index = iend) THEN
  1400.           BEGIN
  1401.           IF (KeyStack [iks] = ibegin) THEN
  1402.              BEGIN
  1403.              PopKey;
  1404.              
  1405.              WHILE (KeyStack [iks] = ido) DO
  1406.                    BEGIN
  1407.                    PopIndent;
  1408.                    PopKey;
  1409.                    END;
  1410.              
  1411.              WHILE (KeyStack [iks] = ielse) DO
  1412.                    BEGIN
  1413.                    PopIndent;
  1414.                    PopKey;
  1415.                    END;
  1416.              
  1417.              IF (KeyStack [iks] = ithen) THEN
  1418.                 BEGIN
  1419.                 PopIndent;
  1420.                 PopKey;
  1421.                 END;
  1422.              
  1423.              IF (KeyStack [iks] = iprocedure) OR (KeyStack [iks] = ifunction) THEN
  1424.                 PopKey;
  1425.              END
  1426.           ELSE
  1427.              IF (KeyStack [iks] = irecord) THEN
  1428.                 BEGIN
  1429.                 PopIndent;
  1430.                 PopKey;
  1431.                 END;
  1432.           END
  1433.        ELSE
  1434.           IF (lastindex = ido) AND
  1435.              (index <> ibegin) AND
  1436.              (index <> iif) AND
  1437.              (index <> ifor) AND
  1438.              (index <> irepeat) AND
  1439.              (index <> iwhile) AND
  1440.              (index <> icase) THEN
  1441.              BEGIN
  1442.              REPEAT
  1443.                PopIndent;
  1444.                PopKey;
  1445.              UNTIL (KeyStack [iks] <> ido);
  1446.              
  1447.              WHILE (KeyStack [iks] = ielse) DO
  1448.                    BEGIN
  1449.                    PopIndent;
  1450.                    PopKey;
  1451.                    END;
  1452.              
  1453.              IF (KeyStack [iks] = ithen) THEN
  1454.                 BEGIN
  1455.                 PopIndent;
  1456.                 PopKey;
  1457.                 END;
  1458.              END
  1459.           ELSE
  1460.              IF (lastindex = ielse) AND
  1461.                 (index <> ibegin) AND
  1462.                 (index <> iif) AND
  1463.                 (index <> ifor) AND
  1464.                 (index <> irepeat) AND
  1465.                 (index <> iwhile) AND
  1466.                 (index <> icase) AND
  1467.                 (index <> iwith) THEN
  1468.                 BEGIN
  1469.                 REPEAT
  1470.                   PopIndent;
  1471.                   PopKey;
  1472.                 UNTIL (KeyStack [iks] <> ielse);
  1473.                 IF (KeyStack [iks] = ithen) THEN
  1474.                    BEGIN
  1475.                    PopIndent;
  1476.                    PopKey;
  1477.                    END;
  1478.                 END
  1479.              ELSE
  1480.                 IF (lastindex = ithen) AND
  1481.                    (index <> ibegin) AND
  1482.                    (index <> iif) AND
  1483.                    (index <> ifor) AND
  1484.                    (index <> irepeat) AND
  1485.                    (index <> iwhile) AND
  1486.                    (index <> icase) AND
  1487.                    (index <> iwith) THEN
  1488.                    BEGIN
  1489.                    PopIndent;
  1490.                    PopKey;
  1491.                    END;
  1492.        
  1493.        IF (index = ibegin) OR
  1494.           (index = ithen) OR
  1495.           (index = ielse) OR
  1496.           (index = ido) OR
  1497.           (index = irepeat) THEN
  1498.           condbreakline;
  1499.        
  1500.        IF (index = ibegin) THEN
  1501.           BEGIN
  1502.           IF (is > 0) THEN
  1503.              PushIndent (BeginIndent)
  1504.           ELSE
  1505.              PushIndent (LeftmostBeginIndent);
  1506.           PushKey (ibegin);
  1507.           END
  1508.        ELSE
  1509.           IF (index = iif) THEN
  1510.              PushIndent (IfIndent)
  1511.           ELSE
  1512.              IF (index = ithen) THEN
  1513.                 PushKey (ithen)
  1514.              ELSE
  1515.                 IF (index = ielse) THEN
  1516.                    BEGIN
  1517.                    IF (KeyStack [iks] <> icase) THEN
  1518.                       BEGIN
  1519.                       PushIndent (ElseIndent);
  1520.                       PushKey (ielse);
  1521.                       END
  1522.                    ELSE
  1523.                       PushIndent (CaseIndent)
  1524.                    END
  1525.                 ELSE
  1526.                    IF (index = iwhile) THEN
  1527.                       PushIndent (WhileIndent)
  1528.                    ELSE
  1529.                       IF (index = ifor) THEN
  1530.                          PushIndent (ForIndent)
  1531.                       ELSE
  1532.                          IF (index = ido) THEN
  1533.                             PushKey (ido)
  1534.                          ELSE
  1535.                             IF (index = irepeat) THEN
  1536.                                BEGIN
  1537.                                PushIndent (RepeatIndent);
  1538.                                PushKey (irepeat);
  1539.                                END
  1540.                             ELSE
  1541.                                IF (index = iuntil) THEN
  1542.                                   BEGIN
  1543.                                   PushIndent (UntilIndent);
  1544.                                   PushKey (iuntil);
  1545.                                   END
  1546.                                ELSE
  1547.                                   IF (index = iconst) THEN
  1548.                                      PushIndent (ConstIndent)
  1549.                                   ELSE
  1550.                                      IF (index = itype) THEN
  1551.                                         PushIndent (TypeIndent)
  1552.                                      ELSE
  1553.                                         IF (index = ivar) THEN
  1554.                                            PushIndent (VarIndent)
  1555.                                         ELSE
  1556.                                            IF (index = irecord) THEN
  1557.                                               BEGIN
  1558.                                               PushIndent (col - 6 - IndentationStack [is]);
  1559.                                               PushIndent (RecordIndent);
  1560.                                               PushKey (irecord);
  1561.                                               condbreakline;
  1562.                                               END
  1563.                                            ELSE
  1564.                                               IF (index = iprocedure) THEN
  1565.                                                  BEGIN
  1566.                                                  PushIndent (ProcedureIndent);
  1567.                                                  PushKey (iprocedure);
  1568.                                                  END
  1569.                                               ELSE
  1570.                                                  IF (index = ifunction) THEN
  1571.                                                     PushKey (ifunction)
  1572.                                                  ELSE
  1573.                                                     IF (index = ilabel) THEN
  1574.                                                        PushIndent (LabelIndent)
  1575.                                                     ELSE
  1576.                                                        IF (index = icase) THEN
  1577.                                                           BEGIN
  1578.                                                           PushIndent (CaseIndent);
  1579.                                                           PushKey (icase);
  1580.                                                           END
  1581.                                                        ELSE
  1582.                                                           IF (index = iof) THEN
  1583.                                                              condbreakline
  1584.                                                           ELSE
  1585.                                                              IF (index = iwith) THEN
  1586.                                                                 PushIndent (WithIndent);
  1587.        
  1588.        CurrentIdentifier := '';
  1589.        UpCaseIdent := '';
  1590.        GOTO start;
  1591.        END;  (* 'A'..'Z', 'a'..'z', '_' *)
  1592.        
  1593.        
  1594.        '0'..'9' :  (* Process decimal integer or real constants *)
  1595.        BEGIN
  1596.        OutPaddedChar (a^ [ia]);
  1597.        INC (ia);
  1598.        IF (ia >= nread) THEN
  1599.           getblock;
  1600.        
  1601.        WHILE ( (a^ [ia] >= '0') AND (a^ [ia] <= '9') ) OR
  1602.              (a^ [ia] = '.') DO
  1603.              BEGIN
  1604.              OutLiteralChar (a^ [ia]);
  1605.              INC (ia);
  1606.              IF (ia >= nread) THEN
  1607.                 getblock;
  1608.              END;
  1609.        
  1610.        IF (a^ [ia] = 'e') OR (a^ [ia] = 'E') THEN
  1611.           BEGIN
  1612.           OutLiteralChar ('e');
  1613.           
  1614.           INC (ia);                   (* Go to the next character *)
  1615.           IF (ia >= nread) THEN
  1616.              getblock;
  1617.           
  1618.           OutLiteralChar (a^ [ia]);   (* Output the sign or digit or (?) *)
  1619.           
  1620.           INC (ia);                   (* Go to the next character *)
  1621.           IF (ia >= nread) THEN
  1622.              getblock;
  1623.           
  1624.           IF ( (lastch >= '0') AND (lastch <= '9') ) OR
  1625.              (lastch = '-') OR
  1626.              (lastch = '+') THEN
  1627.              WHILE ( (a^ [ia] >= '0') AND (a^ [ia] <= '9') ) OR
  1628.                    (a^ [ia] = '.') DO
  1629.                    BEGIN
  1630.                    OutLiteralChar (a^ [ia]);
  1631.                    INC (ia);
  1632.                    IF (ia >= nread) THEN
  1633.                       getblock;
  1634.                    END;
  1635.           END; (* if *)
  1636.        GOTO start;
  1637.        END;  (* '0'..'9' *)
  1638.        
  1639.        
  1640.        '$' :  (* Process hexadecimal constants, specific to Turbo Pascal *)
  1641.        BEGIN
  1642.        OutPaddedChar ('$');
  1643.        INC (ia);
  1644.        IF (ia >= nread) THEN
  1645.           getblock;
  1646.        WHILE ( (a^ [ia] >= 'a') AND (a^ [ia] <= 'f') ) OR
  1647.              ( (a^ [ia] >= 'A') AND (a^ [ia] <= 'F') ) OR
  1648.              ( (a^ [ia] >= '0') AND (a^ [ia] <= '9') ) DO
  1649.              BEGIN
  1650.              OutLiteralChar (a^ [ia]);
  1651.              INC (ia);
  1652.              IF (ia >= nread) THEN
  1653.                 getblock;
  1654.              END;
  1655.        GOTO start;
  1656.        END;  (* '$' *)
  1657.        
  1658.   ELSE
  1659.        
  1660.        BEGIN
  1661.        OutPaddedChar (ch);
  1662.        INC (ia);
  1663.        IF (ia >= nread) THEN
  1664.           getblock;
  1665.        GOTO start;
  1666.        END;
  1667.        
  1668.   END;  (* CASE ch *)
  1669.   
  1670. END.
  1671.